home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / dispatch.t < prev    next >
Text File  |  1988-05-02  |  7KB  |  178 lines
  1. (herald dispatch (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Specific routines generation
  27.  
  28. ;;; Mung a random piece of s-expression into a bunch of SET-DISPATCHES
  29. ;;; that define all the routines for generic arithmetic.
  30.  
  31. (define-local-syntax (define-specific-ops . data)
  32.   (labels (((process-one-specific-entry entry)
  33.             (let ((types (car entry))
  34.                   (opspecs (cdr entry)))
  35.               `(set-dispatches
  36.                 ,(concatenate-symbol '%% (car types) '-number-type)
  37.                 ,(concatenate-symbol '%% (cadr types) '-number-type)
  38.                 ,@(process-subentries opspecs))))
  39.  
  40.            ((process-subentries specs)
  41.              (let ((probe (apply append (map car specs))))
  42.                (cond ((not (alikev? probe
  43.                                     '(add subtract multiply divide
  44.                                           quotient less? equal?)))
  45.                       (error "bad clause order in subentry~%  ~S"
  46.                              probe))))
  47.              (apply append! (map process-subentry specs)))
  48.  
  49.            ((process-subentry subentry)
  50.              (map (lambda (op) (hacked-eval (cadr subentry) op))
  51.                   (car subentry)))
  52.  
  53.            ((hacked-eval form opval)
  54.              (cond ((eq? form 'op)     opval)
  55.                    ((eq? form 'conc)   concatenate-symbol)
  56.                    ((eq? form 'specop) specop)
  57.                    ((pair? form)
  58.                     (cond ((eq? (car form) 'quote) (cadr form))
  59.                           (else
  60.                            (apply (hacked-eval (car form) opval)
  61.                                   (map (lambda (a) (hacked-eval a opval))
  62.                                        (cdr form))))))
  63.                    (else (error "cannot HACKED-EVAL ~S" form))))
  64.  
  65. ;;; Construct code for specific routines to {add, subtract, multiply,
  66. ;;; divide} two numbers, one of type OPD1 and the other of type
  67. ;;; OPD2.  The routine will coerce OPD1 and OPD2 to OPR-TYPE and
  68. ;;; then apply the appropriate type-specific arithmetic routine.
  69.  
  70.            ((specop opr opd1 opd2 opr-type)
  71.              `(lambda (x y) (,(concatenate-symbol opr-type '- opr)
  72.                              ,(coerced-operand 'x opd1 opr-type)
  73.                              ,(coerced-operand 'y opd2 opr-type))))
  74.  
  75.            ((coerced-operand operand opd-type opr-type)
  76.              (cond ((neq? opd-type opr-type)
  77.                     `(,(concatenate-symbol opd-type '-> opr-type) ,operand))
  78.                    (else operand))))
  79.  
  80. ;;; This is the last form in the initial (locale () ...).  It yields
  81. ;;; the form which will actually be compiled.  (All the above code
  82. ;;; is ephemeral - it exists only at compile time.)
  83.  
  84.     `(block ,@(map process-one-specific-entry data))))
  85.  
  86.  
  87. ;;; Order of ops is significant!
  88.  
  89. (define-specific-ops
  90.  
  91.   ((fixnum fixnum)
  92.    ((add subtract multiply divide) (conc 'fixnum- op '-carefully))
  93.    ((quotient) 'fixnum-divide)
  94.    ((less? equal?) (conc 'fixnum- op)))
  95.  
  96.   ((fixnum flonum)
  97.    ((add subtract multiply divide)
  98.     (specop op 'fixnum 'flonum 'flonum))
  99.    ((quotient)
  100.     '(lambda (x y) (flonum-divide (fixnum->flonum x) y)))
  101.    ((less? equal?)
  102.     (specop op 'fixnum 'flonum 'flonum)))
  103.  
  104.   ((fixnum bignum)
  105.    ((add subtract multiply) (specop op 'fixnum 'bignum 'bignum))
  106.    ((divide) 'ratio) 
  107.    ((quotient)
  108.     '(lambda (x y) 
  109.        (if (and (fx= x most-negative-fixnum)        ;Thanks to Joe Stoy!
  110.                 (= y (- most-negative-fixnum)))
  111.            -1
  112.            0)))
  113.    ((less?)  '(lambda (x y) (ignore x) (bignum-positive? y)))
  114.    ((equal?) 'false))
  115.  
  116.   ((fixnum ratio)
  117.    ((add subtract multiply divide quotient less?) (conc 'rational- op))
  118.    ((equal?) 'false))
  119.  
  120.   ((flonum fixnum)
  121.    ((add subtract multiply divide) (specop op 'flonum 'fixnum 'flonum))
  122.    ((quotient) '(lambda (x y) (flonum-divide x (fixnum->flonum y))))
  123.    ((less? equal?) (specop op 'flonum 'fixnum 'flonum)))
  124.  
  125.   ((flonum flonum)
  126.    ((add subtract multiply divide)  (conc 'flonum- op))
  127.    ((quotient) 'flonum-divide)
  128.    ((less? equal?) (conc 'flonum- op)))
  129.  
  130.   ((flonum bignum)
  131.    ((add subtract multiply divide) (specop op 'flonum 'bignum 'flonum))
  132.    ((quotient) '(lambda (x y) (flonum-divide x (bignum->flonum y))))
  133.    ((less? equal?) (specop op 'flonum 'bignum 'flonum)))
  134.  
  135.   ((flonum ratio)
  136.    ((add subtract multiply divide) (specop op 'flonum 'ratio 'flonum))
  137.    ((quotient) '(lambda (x y) (flonum-divide x (ratio->flonum y))))
  138.    ((less? equal?) (specop op 'flonum 'ratio 'flonum)))
  139.  
  140.   ((ratio fixnum)
  141.    ((add subtract multiply divide quotient less?) (conc 'rational- op))
  142.    ((equal?) 'false))
  143.  
  144.   ((ratio flonum)
  145.    ((add subtract multiply divide) (specop op 'ratio 'flonum 'flonum))
  146.    ((quotient) '(lambda (x y) (flonum-divide x (ratio->flonum y))))
  147.    ((less? equal?) (specop op 'ratio 'flonum 'flonum)))
  148.  
  149.   ((ratio bignum)
  150.    ((add subtract multiply divide quotient less?) (conc 'rational- op))
  151.    ((equal?) 'false))
  152.  
  153.   ((ratio ratio)
  154.    ((add subtract multiply divide quotient less? equal?) (conc 'rational- op)))
  155.  
  156.   ((bignum fixnum)
  157.    ((add subtract multiply) (specop op 'bignum 'fixnum 'bignum))
  158.    ((divide) 'ratio)
  159.    ((quotient)    'b-f-divide)
  160.    ((less?)  '(lambda (x y) (ignore y) (not (bignum-positive? x))))
  161.    ((equal?) 'false))
  162.  
  163.   ((bignum flonum)
  164.    ((add subtract multiply divide) (specop op 'bignum 'flonum 'flonum))
  165.    ((quotient) '(lambda (x y) (flonum-divide (bignum->flonum x) y)))
  166.    ((less? equal?) (specop op 'bignum 'flonum 'flonum)))
  167.  
  168.   ((bignum bignum)
  169.    ((add subtract multiply) (conc 'bignum- op))
  170.    ((divide) 'ratio)
  171.    ((quotient) 'bignum-divide)
  172.    ((less? equal?) (conc 'bignum- op)))
  173.   
  174.   ((bignum ratio)
  175.    ((add subtract multiply divide quotient less?) (conc 'rational- op))
  176.    ((equal?) 'false))
  177.   )
  178.